home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / MacGofer 0.22d / MacGofer Sources / cmachine.c < prev    next >
Encoding:
Text File  |  1994-01-07  |  51.7 KB  |  1,653 lines  |  [TEXT/MPS ]
  1. FloatPro fl; {
  2. #if BREAK_FLOATS
  3.     lastInstr         = getMem(3);
  4.     instrAt(lastInstr)     = opc;
  5.     cellAt(lastInstr+1)     = part1Float(fl);
  6.     cellAt(lastInstr+2)     = part2Float(fl);
  7. #else
  8.     lastInstr            = getMem(2);
  9.     instrAt(lastInstr)   = opc;
  10.     floatAt(lastInstr+1) = fl;
  11. #endif
  12. }
  13.  
  14. static Void local instrCell(opc,c)    /* Opcode with Cell operand       */
  15. Instr opc;
  16. Cell  c; {
  17.     lastInstr        = getMem(2);
  18.     instrAt(lastInstr)    = opc;
  19.     cellAt(lastInstr+1) = c;
  20. }
  21.  
  22. static Void local instrText(opc,t)    /* Opcode with Text operand       */
  23. Instr opc;
  24. Text  t; {
  25.     lastInstr        = getMem(2);
  26.     instrAt(lastInstr)    = opc;
  27.     textAt(lastInstr+1) = t;
  28. }
  29.  
  30. static Void local instrLab(opc,l)    /* Opcode with label operand       */
  31. Instr opc;
  32. Label l; {
  33.     lastInstr           = getMem(2);
  34.     instrAt(lastInstr) = opc;
  35.     labAt(lastInstr+1) = l;
  36.     if (l<0)
  37.     internal("bad Label");
  38. }
  39.  
  40. static Void local instrIntLab(opc,n,l)    /* Opcode with int, label operands */
  41. Instr opc;
  42. Int   n;
  43. Label l; {
  44.     lastInstr           = getMem(3);
  45.     instrAt(lastInstr) = opc;
  46.     intAt(lastInstr+1) = n;
  47.     labAt(lastInstr+2) = l;
  48.     if (l<0)
  49.     internal("bad Label");
  50. }
  51.  
  52. static Void local instrCellLab(opc,c,l)    /* Opcode with cell, label operands*/
  53. Instr opc;
  54. Cell  c;
  55. Label l; {
  56.     lastInstr        = getMem(3);
  57.     instrAt(lastInstr)    = opc;
  58.     cellAt(lastInstr+1) = c;
  59.     labAt(lastInstr+2)    = l;
  60.     if (l<0)
  61.     internal("bad Label");
  62. }
  63.  
  64. /* --------------------------------------------------------------------------
  65.  * Main low level assembler control: (includes label assignment and fixup)
  66.  * ------------------------------------------------------------------------*/
  67.  
  68. static    Label        nextLab;        /* next label number to allocate   */
  69. #if DYNAMIC_STORAGE
  70.         Label       *fixups;
  71. #else
  72. static  Label       fixups[NUM_FIXUPS]; /* fixups for label values       */
  73. #endif
  74. #define FAIL        0            /* special label for fail()       */
  75.  
  76. #define fix(a)      labAt(a) = fixups[labAt(a)]
  77.  
  78. static Void local asSTART() {        /* initialise assembler           */
  79.     fixups[0]    = FAIL;            /* use label 0 for fail()       */
  80.     nextLab    = 1;
  81.     startInstr    = getMem(0);
  82.     lastInstr    = startInstr-1;
  83.     srsp    = 0;
  84.     offsPosn[0]    = 0;
  85. }
  86.  
  87. static Label local newLabel() {        /* allocate new label           */
  88.     if (nextLab>=NUM_FIXUPS) {
  89.     ERROR(0) "Compiled code too complex"
  90.     EEND;
  91.     }
  92.     return nextLab++;
  93. }
  94.  
  95. static Void local asLABEL(l)        /* indicate label reached       */
  96. Label l; {
  97.     if (instrAt(lastInstr)==iGOTO && labAt(lastInstr+1)==l) {
  98.     instrAt(lastInstr) = iLABEL;    /* GOTO l; LABEL l  ==>  LABEL l   */
  99.     fixups[l] = l;
  100.     }
  101.     else if (instrAt(lastInstr)==iLABEL)/* code already labelled at this pt*/
  102.     fixups[l] = labAt(lastInstr+1);    /* so use previous label       */
  103.     else {
  104.     instrLab(iLABEL,l);        /* otherwise insert new label       */
  105.     fixups[l] = l;
  106.     }
  107. }
  108.  
  109. static Void local asEND() {        /* Fix addresses in assembled code */
  110.     Addr pc = startInstr;
  111.  
  112.     instrNone(iEND);            /* insert END opcode           */
  113.     for (;;)
  114.     switch (instrAt(pc)) {
  115.         case iEND     : return;    /* end of code sequence           */
  116.  
  117.         case iEVAL     :        /* opcodes taking no arguments       */
  118.         case iFLUSH  :
  119.         case iRETURN : pc++;
  120.                break;
  121.  
  122.         case iGOTO     : fix(pc+1);    /* opcodes taking one argument       */
  123.         case iLABEL     : /* no need for a fix here !*/
  124.         case iSETSTK :
  125.         case iSTKIS :
  126.         case iALLOC  :
  127.         case iSLIDE  :
  128.         case iROOT     :
  129.             case iDICT   :
  130.         case iLOAD     :
  131.         case iCELL     :
  132.         case iCHAR     :
  133.         case iINT     :
  134. #if !BREAK_FLOATS
  135.           case iFLOAT  :
  136. #endif
  137.         case iSTRING :
  138.         case iMKAP     :
  139.         case iUPDATE :
  140.         case iUPDAP  : pc+=2;
  141.                break;
  142.  
  143. #if BREAK_FLOATS
  144.         case iFLOAT  : pc+=3;
  145.                break;
  146. #endif
  147.         case iINTGE  :        /* opcodes taking two arguments       */
  148.         case iINTEQ  :
  149.         case iINTDV     :
  150.         case iTEST     : fix(pc+2);
  151.                pc+=3;
  152.                break;
  153.  
  154.         default     : internal("asEND");
  155.     }
  156. }
  157.  
  158. /* --------------------------------------------------------------------------
  159.  * Assembler Opcodes: (includes simple peephole optimisations)
  160.  * ------------------------------------------------------------s; {
  161. #if BREAK_FLOATS
  162.     printf("%s\t%s\n",s,
  163.     floatToString(floatFromParts(cellAt(pc+1),cellAt(pc+2))));
  164.     return pc+3;
  165. #else
  166.     printf("%s\t%s\n",s,floatToString(floatAt(pc+1)));
  167.     return pc+2;
  168. #endif
  169. }
  170.  
  171. static Addr local dissCell(pc,s)       /* dissassemble instr with Cell arg */
  172. Addr   pc;
  173. String s; {
  174.     printf("%s\t",s);
  175.     printCell(cellAt(pc+1));
  176.     printf("\n");
  177.     return pc+2;
  178. }
  179.  
  180. static Addr local dissText(pc,s)       /* dissassemble instr with Text arg */
  181. Addr   pc;
  182. String s; {
  183.     printf("%s\t%s\n",s,textToStr(textAt(pc+1)));
  184.     return pc+2;
  185. }
  186.  
  187. static Addr local dissLab(pc,s)       /* dissassemble instr with Label arg */
  188. Addr   pc;
  189. String s; {
  190.     printf("%s\t%d\n",s,labAt(pc+1));
  191.     return pc+2;
  192. }
  193.  
  194. static Addr local dissIntLab(pc,s)    /* dissassemble instr with Int+Label */
  195. Addr   pc;
  196. String s; {
  197.     printf("%s\t%d\t%d\n",s,intAt(pc+1),labAt(pc+2));
  198.     return pc+3;
  199. }
  200.  
  201. static Addr local dissCellLab(pc,s)   /* dissassemble instr with Cell+Label*/
  202. Addr   pc;
  203. String s; {
  204.     printf("%s\t",s);
  205.     printCell(cellAt(pc+1));
  206.     printf("\t%d\n",labAt(pc+2));
  207.     return pc+3;
  208. }
  209. #endif
  210.  
  211. /* --------------------------------------------------------------------------
  212.  * Compile expression to code which will build expression evaluating guards
  213.  * and testing cases to avoid building complete graph.
  214.  *
  215.  * This section of code has been rewritten from the original form in
  216.  * version 2.21 of the interpreter to use a more sophisticated form of
  217.  * continuation rather than the simple UPDRET/SHOULDNTFAIL/label etc
  218.  * used in that program.  The aim of this rewrite is (of course) to try
  219.  * and produce better output code.  The basic type for continuations is:
  220.  *
  221.  *    type Continuation = (Int, ThenWhat)
  222.  *    data ThenWhat      = RUNONC         -- next instr
  223.  *              | FRUNONC        -- FLUSH then next instr
  224.  *              | BRANCH Label    -- branch to label
  225.  *              | FBRANCH Label    -- FLUSH then branch
  226.  *              | UPDRETC        -- UPDATE 0; RETURN
  227.  *
  228.  * As an example of the kind of optimisations we can get by this:
  229.  *
  230.  *  ...; MKAP 4; SLIDE m ; UPDATE 0 ; RETURN
  231.  *                     ====> ...; MKAP 3; UPDAP 0; RETURN
  232.  *
  233.  *  ...; MKAP 2; FLUSH ; UPDATE 0; RETURN
  234.  *                     ====> ...; MKAP 1; UPDAP 0; RETURN
  235.  *
  236.  *  ...; SLIDE m; SLIDE n; ...       ====> ...; SLIDE (m+n); ...
  237.  *  (this one was previously obtained by a peephole optimisation)
  238.  * ------------------------------------------------------------------------*/
  239.  
  240. static Pair shouldntFail;        /* error continuation           */
  241. static Pair functionReturn;        /* initial function continuation   */
  242. static Pair noAction;            /* skip continuation           */
  243.  
  244. static Void local doCont(c)        /* insert code for continuation    */
  245. Pair c; {
  246.     Int sl = intOf(fst(c));
  247.     switch (whatIs(snd(c))) {
  248.     case FRUNONC : asFLUSH();
  249.     case RUNONC  : if (sl>0) {
  250.                asSLIDE(sl);
  251.                }
  252.                break;
  253.  
  254.     case FBRANCH : asFLUSH();
  255.     case BRANCH  : if (sl>0) {
  256.                asSLIDE(sl);
  257.                }
  258.                asGOTO(intOf(snd(snd(c))));
  259.                break;
  260.  
  261.     case UPDRETC : asUPDATE(0);
  262.                asRETURN();
  263.                        break;
  264.  
  265.     case ERRCONT :
  266.     default         : internal("doCont");
  267.     }
  268. }
  269.  
  270. #define slide(n,d)   pair(mkInt(intOf(fst(d))+n),snd(d))
  271. #define isRunon(d)   (snd(d)==RUNONC || snd(d)==FRUNONC)
  272. #define fbranch(l,d) pair(fst(d),ap(FBRANCH,l))
  273. #define frunon(d)    pair(fst(d),FRUNONC)
  274.  
  275. static Pair local flush(d)        /* force flush on continuation       */
  276. Pair d; {
  277.     switch (whatIs(snd(d))) {
  278.     case RUNONC : return frunon(d);
  279.     case BRANCH : return fbranch(snd(snd(d)),d);
  280.     default        : return d;
  281.     }
  282. }
  283.  
  284. static Void local make(e,co,f,d)    /* Construct code to build e, given*/
  285. Cell  e;                /* current offset co, and branch   */
  286. Int   co;                /* to f on failure, d on completion*/
  287. Label f;
  288. Pair  d; {
  289.     switch (whatIs(e)) {
  290.  
  291.     case LETREC    : {   Int n = buildLoc(fst(snd(e)),co);
  292.                  make(snd(snd(e)),co+n,f,slide(n,d));
  293.                  }
  294.                  break;
  295.  
  296.     case FATBAR    : if (isRunon(d)) {
  297.                  Label l1     = newLabel();
  298.                  Label l2     = newLabel();
  299.                  Int   savesp = srsp;
  300.                  make(fst(snd(e)),co,l1,fbranch(mkInt(l2),d));
  301.                  asLABEL(l1);
  302.                   asSETSTK(savesp);
  303.                  make(snd(snd(e)),co,f,frunon(d));
  304.                  asLABEL(l2);
  305.              }
  306.              else {
  307.                  Label l  = newLabel();
  308.                  Cell  d1 = flush(d);
  309.                  Int   savesp = srsp;
  310.                  make(fst(snd(e)),co,l,d1);
  311.                  asLABEL(l);
  312.                  asSETSTK(savesp);
  313.                  make(snd(snd(e)),co,f,d1);
  314.              }
  315.                          break;
  316.  
  317.     case COND      : makeCond(fst3(snd(e)),
  318.                   snd3(snd(e)),
  319.                   thd3(snd(e)),co,f,d);
  320.                  break;
  321.  
  322.     case CASE      : makeCase(snd(e),co,f,d);
  323.              break;
  324.  
  325.     case GUARDED   : makeGded(snd(e),co,f,d);
  326.                  break;
  327.  
  328.     case AP        : if (andorOptimise) {
  329.                  Cell h = getHead(e);
  330.                  if (h==nameAnd && argCount==2) {
  331.                  /* x && y ==> if x then y else False       */
  332.                  makeCond(arg(fun(e)),arg(e),nameFalse,co,f,d);
  333.                  break;
  334.                  }
  335.                  else if (h==nameOr && argCount==2) {
  336.                  /* x || y ==> if x then True else y       */
  337.                  makeCond(arg(fun(e)),nameTrue,arg(e),co,f,d);
  338.                  break;
  339.                  }
  340.              }
  341.                          buildAp(e,co,f,TRUE);
  342.                          doCont(d);
  343.                          break;
  344.  
  345.     case NAME      : dependsOn(e);
  346.     case UNIT      :
  347.     case TUPLE     : asCELL(e);
  348.                  doCont(d);
  349.                  break;
  350.  
  351.     /* for dict cells, ensure that CELL referred to in the code is the */
  352.     /* dictionary cell at the head of the dictionary; not just a copy  */
  353.     /* In the interpreter, this was needed for the benefit of garbage  */
  354.     /* collection (and to avoid having multiple copies of a single       */
  355.     /* DICTCELL).  In the compiler, we need it to justify the use of   */
  356.     /* cellIsMember() in dependsOn() below.                   */
  357.  
  358.     case DICTCELL  : asCELL(dict(dictOf(e)));
  359.              dependsOn(dict(dictOf(e)));
  360.                  doCont(d);
  361.                  break;
  362.  
  363.     case INTCELL   : asINTEGER(intOf(e));
  364.                  doCont(d);
  365.                  break;
  366.  
  367.         case FLOATCELL : asFLOAT(floatOf(e));
  368.                  doCont(d);
  369.              break;
  370.  
  371.     case STRCELL   : asSTRING(textOf(e));
  372.                  doCont(d);
  373.                  break;
  374.  
  375.     case CHARCELL  : asCHAR(charOf(e));
  376.                  doCont(d);
  377.                  break;
  378.  
  379.     case OFFSET    : asLOAD(offsPosn[offsetOf(e)]);
  380.                  doCont(d);
  381.                  break;
  382.  
  383.     default        : internal("make");
  384.     }
  385. }
  386.  
  387. static Void local makeCond(i,t,e,co,f,d)/* Build code for conditional       */
  388. Cell  i,t,e;
  389. Int   co;
  390. Label f;
  391. Pair  d; {
  392.     if (andorOptimise && i==nameOtherwise)
  393.     make(t,co,f,d);
  394.     else {
  395.     Label l1 = newLabel();
  396.     Int   savesp;
  397.  
  398.     make(i,co,f,noAction);
  399.     asEVAL();
  400.     savesp = srsp;
  401.     asTEST(nameTrue,l1);
  402.     if (isRunon(d)) {
  403.         Label l2 = newLabel();
  404.  
  405.         make(t,co,f,fbranch(mkInt(l2),d));
  406.             asLABEL(l1);
  407.          if (srsp!=savesp)
  408.          asSETSTK(savesp);
  409.         make(e,co,f,frunon(d));
  410.         asLABEL(l2);
  411.     }
  412.     else {
  413.         Cell d1 = flush(d);
  414.         make(t,co,f,d1);
  415.         asLABEL(l1);
  416.         if (srsp!=savesp)
  417.         asSETSTK(savesp);
  418.         make(e,co,f,d1);
  419.     }
  420.     }
  421. }
  422.  
  423. static Void local makeCase(c,co,f,d)    /* construct code to implement case*/
  424. Cell  c;                /* makes the assumption that FLUSH */
  425. Int   co;                /* will never be required       */
  426. Label f;
  427. Pair  d; {
  428.     List  cs = snd(c);
  429.     Cell  d1 = d;
  430.     Label l0;
  431.  
  432.     make(fst(c),co,shouldntFail,noAction);
  433.     asEVAL();
  434.  
  435.     if (isRunon(d)) {
  436.     l0 = newLabel();
  437.     d1 = pair(mkInt(0),ap(BRANCH,mkInt(l0)));
  438.     }
  439.  
  440.     for(; nonNull(tl(cs)); cs=tl(cs)) {
  441.     Label l      = newLabel();
  442.         Int   savesp = srsp;
  443.     testCase(hd(cs),co,f,l,d1);
  444.     asLABEL(l);
  445.     asSTKIS(srsp);
  446.      }
  447.  
  448.     if (isRunon(d)) {
  449.         Int savesp = srsp;
  450.     testCase(hd(cs),co,f,f,noAction);
  451.     asLABEL(l0);
  452.         srsp = savesp;
  453.     }
  454.     else
  455.     testCase(hd(cs),co,f,f,d1);
  456. }
  457.  
  458. static Void local testCase(c,co,f,cf,d)    /* Produce code for guard       */
  459. Pair  c;
  460. Int   co;                /* labels determine where to go if:*/
  461. Label f;                /* match succeeds, but rest fails  */
  462. Label cf;                /* this match fails           */
  463. Pair  d; {
  464.     Int n = discrArity(fst(c));
  465.     Int i;
  466.     switch (whatIs(fst(c))) {
  467.     case INTCELL : asINTEQ(intOf(fst(c)),cf);
  468.                break;
  469.     case ADDPAT  : asINTGE(intValOf(fst(c)),cf);
  470.                break;
  471.     case MULPAT  : asINTDV(intValOf(fst(c)),cf);
  472.                break;
  473.     default      : asTEST(fst(c),cf);
  474.                break;
  475.     }
  476.     for (i=1; i<=n; i++)
  477.     offsPosn[co+i] = ++srsp;
  478.     make(snd(c),co+n,f,d);
  479. }
  480.  
  481. static Void local makeGded(gs,co,f,d)    /* construct code to implement gded*/
  482. List  gs;                /* equations.  Makes the assumption*/
  483. Int   co;                /* that FLUSH will never be reqd.  */
  484. Label f;
  485. Pair  d; {
  486.     Cell  d1 = d;
  487.     Label l0;
  488.  
  489.     if (isRunon(d)) {
  490.     l0 = newLabel();
  491.     d1 = pair(mkInt(0),ap(BRANCH,mkInt(l0)));
  492.     }
  493.  
  494.     for(; nonNull(tl(gs)); gs=tl(gs)) {
  495.     Label l = newLabel();
  496.         Int   savesp = srsp;
  497.     if (testGuard(hd(gs),co,f,l,d1))
  498.         return;
  499.     asLABEL(l);
  500.     asSTKIS(srsp);
  501.     }
  502.  
  503.     if (isRunon(d)) {
  504.         Int   savesp = srsp;
  505.     testGuard(hd(gs),co,f,f,noAction);
  506.     asLABEL(l0);
  507.     asSTKIS(srsp);
  508.     }
  509.     else
  510.     testGuard(hd(gs),co,f,f,d1);
  511. }
  512.  
  513. static Bool local testGuard(g,co,f,cf,d) /* Produce code for guard       */
  514. Pair  g;                /* return TRUE if otherwise found  */
  515. Int   co;
  516. Label f;
  517. Label cf;
  518. Pair  d; {
  519.     if (andorOptimise && fst(g)==nameOtherwise) {
  520.     make(snd(g),co,f,d);
  521.     return TRUE;
  522.     }
  523.     else {
  524.     make(fst(g),co,shouldntFail,noAction);
  525.     asEVAL();
  526.     asTEST(nameTrue,cf);
  527.     make(snd(g),co,f,d);
  528.     return FALSE;
  529.     }
  530. }
  531.  
  532. /* --------------------------------------------------------------------------
  533.  * Compile expression to code which will build expression without any
  534.  * evaluation.
  535.  * ------------------------------------------------------------------------*/
  536.  
  537. static List scDeps;            /* records immediate dependent       */
  538.                     /* names and dictionaries       */
  539.  
  540. static Void local dependsOn(n)        /* update scDeps with new name       */
  541. Cell n; {
  542.  
  543.     if (isName(n))            /* ignore:               */
  544.     if (name(n).defn == CFUN ||    /* - constructor functions       */
  545.         name(n).defn == MFUN)    /* - member fns (shouldn't occur)  */
  546.         return;
  547.  
  548.     if (!cellIsMember(n,scDeps))    /* add to list of dependents       */
  549.     scDeps = cons(n,scDeps);
  550. }
  551.  
  552. static Void local build(e,co)        /* Generate code which will build  */
  553. Cell e;                 /* instance of given expression but*/
  554. Int  co; {                /* perform no evaluation        */
  555.     Int n;
  556.  
  557.     switch (whatIs(e)) {
  558.  
  559.     case LETREC    : n = buildLoc(fst(snd(e)),co);
  560.                  build(snd(snd(e)),co+n);
  561.                  asSLIDE(n);
  562.                  break;
  563.  
  564.     case FATBAR    : build(snd(snd(e)),co);
  565.                  build(fst(snd(e)),co);
  566.                  asCELL(nameFatbar);
  567.                  asMKAP(2);
  568.                  break;
  569.  
  570.     case COND      : build(thd3(snd(e)),co);
  571.                  build(snd3(snd(e)),co);
  572.                  build(fst3(snd(e)),co);
  573.                  asCELL(nameIf);
  574.                    asMKAP(3);
  575.                    break;
  576.  
  577.     case GUARDED   : buildGuards(snd(e),co);
  578.                  break;
  579.  
  580.     case AP        : buildAp(e,co,shouldntFail,FALSE);
  581.                  break;
  582.  
  583.     case NAME      : dependsOn(e);
  584.     case UNIT      :
  585.     case TUPLE     : asCELL(e);
  586.              break;
  587.  
  588.     case DICTCELL  : asCELL(dict(dictOf(e)));    /* see comments for*/
  589.              dependsOn(dict(dictOf(e)));    /* DICTCELL in make*/
  590.              break;                /* function above  */
  591.  
  592.     case INTCELL   : asINTEGER(intOf(e));
  593.              break;
  594.  
  595.         case FLOATCELL : asFLOAT(floatOf(e));
  596.              break;
  597.  
  598.     case STRCELL   : asSTRING(textOf(e));
  599.              break;
  600.  
  601.     case CHARCELL  : asCHAR(charOf(e));
  602.              break;
  603.  
  604.     case OFFSET    : asLOAD(offsPosn[offsetOf(e)]);
  605.                  break;
  606.  
  607.     default        : internal("build");
  608.     }
  609. }
  610.  
  611. static Void local buildGuards(gs,co)    /* Generate code to compile list   */
  612. List gs;                /* of guards to a conditional expr */
  613. Int  co; {                /* without evaluation           */
  614.     if (isNull(gs)) {
  615.     asCELL(nameFail);
  616.     }
  617.     else {
  618.     buildGuards(tl(gs),co);
  619.     build(snd(hd(gs)),co);
  620.     build(fst(hd(gs)),co);
  621.     asCELL(nameIf);
  622.     asMKAP(3);
  623.     }
  624. }
  625.  
  626. static Int local buildLoc(vs,co)    /* Generate code to build local var*/
  627. List vs;                /* bindings on stack,  with no eval*/
  628. Int  co; {
  629.     Int n = length(vs);
  630.     Int i;
  631.  
  632.     for (i=1; i<=n; i++)
  633.     offsPosn[co+i] = srsp+i;
  634.     asALLOC(n);
  635.     for (i=1; i<=n; i++) {
  636.     build(hd(vs),co+n);
  637.     asUPDATE(offsPosn[co+i]);
  638.     vs = tl(vs);
  639.     }
  640.     return n;
  641. }
  642.  
  643. /* --------------------------------------------------------------------------
  644.  * We frequently encounter functions which call themselves recursively with
  645.  * a number of initial arguments preserved:
  646.  * e.g.  (map f) []    = []
  647.  *     (map f) (x:xs) = f x : (map f) xs
  648.  * Lambda lifting, in particular, is likely to introduce such functions.
  649.  * Rather than reconstructing a new instance of the recursive function and
  650.  * it's arguments, we can extract the relevant portion of the root of the
  651.  * current redex.
  652.  *
  653.  * The following functions implement this optimisation.
  654.  * ------------------------------------------------------------------------*/
  655.  
  656. static Int  nonRoots;               /* #args which can't get from root  */
  657. static Int  rootPortion;           /* portion of root used ...       */
  658. static Name definingName;           /* name of func being defined,if any*/
  659. static Int  definingArity;           /* arity of definingName        */
  660.  
  661. static Void local analyseAp(e)           /* Determine if any portion of an   */
  662. Cell e; {                   /* application can be built using a */
  663.     if (isAp(e)) {               /* portion of the root           */
  664.     analyseAp(fun(e));
  665.     if (nonRoots==0 && rootPortion>1
  666.             && isOffset(arg(e))
  667.             && offsetOf(arg(e))==rootPortion-1)
  668.         rootPortion--;
  669.     else
  670.         nonRoots++;
  671.     }
  672.     else if (e==definingName)
  673.     rootPortion = definingArity+1;
  674.     else
  675.     rootPortion = 0;
  676. }
  677.  
  678. static Void local buildAp(e,co,f,str)    /* Build application, making use of*/
  679. Cell  e;                /* root optimisation if poss.       */
  680. Int   co;
  681. Label f;
  682. Bool  str; {
  683.     Int nr, rp, i;
  684.  
  685.     nonRoots = 0;
  686.     analyseAp(e);
  687.     nr = nonRoots;
  688.     rp = rootPortion;
  689.  
  690.     for (i=0; i<nr; ++i) {
  691.     build(arg(e),co);
  692.     e = fun(e);
  693.     }
  694.  
  695.     if (isSelect(e)) {
  696.         if (selectOf(e)>0) {
  697.         asDICT(selectOf(e));
  698.     }
  699.     }
  700.     else {
  701.     if (isName(e) && name(e).defn==MFUN) {
  702.         asDICT(name(e).number);
  703.         nr--;    /* AP node for member function need never be built */
  704.     }
  705.     else {
  706.         if (0<rp && rp<=definingArity) {
  707.         asROOT(rp-1);
  708.         }
  709.         else
  710.         if (str)
  711.             make(e,co,f,noAction);
  712.         else
  713.             build(e,co);
  714.     }
  715.  
  716.     if (nr>0) {
  717.         asMKAP(nr);
  718.     }
  719.     }
  720. }
  721.  
  722. /* --------------------------------------------------------------------------
  723.  * Code generator entry point:
  724.  * ------------------------------------------------------------------------*/
  725.  
  726. Addr codeGen(n,arity,e)            /* Generate code for expression e,  */
  727. Name n;                    /* treating return value of CAFs    */
  728. Int  arity;                   /* differently to functs with args  */
  729. Cell e; {
  730.     extern Void pScDef Args((Text,Int,Cell));
  731.     extern Bool dumpScs;
  732.  
  733.     definingName  = n;
  734.     definingArity = arity;
  735.     scDeps      = NIL;
  736. #ifdef DEBUG_CODE
  737. printf("------------------\n");
  738. if (nonNull(n)) printf("name=%s\n",textToStr(name(n).text));
  739. printf("Arity   = %d\n",arity);
  740. printf("codeGen = "); printExp(stdout,e); putchar('\n');
  741. #endif
  742.     if (dumpScs)
  743.     pScDef(name(n).text,arity,e);
  744.     else {
  745.     Int i;
  746.     asSTART();
  747.     for (i=1; i<=arity; i++)
  748.         offsPosn[i] = ++srsp;
  749.     make(e,arity,FAIL,functionReturn);
  750.     asEND();
  751.     }
  752.     name(n).defn = scDeps;
  753.     scDeps     = NIL;
  754. #ifdef DEBUG_CODE
  755. dissassemble(startInstr);
  756. printf("------------------\n");
  757. #endif
  758.     return startInstr;
  759. }
  760.  
  761. /* --------------------------------------------------------------------------
  762.  * C code generator: produces (portable, I hope) C output to implement a
  763.  * specified main program.
  764.  * ------------------------------------------------------------------------*/
  765.  
  766. Void outputCode(fp,mn)            /* print complete C program to       */
  767. FILE *fp;                /* implement program mn :: Dialogue*/
  768. Name mn; {
  769.     List   scs = identifyDeps(mn);    /* determine which supercombinator */
  770.     Target t   = length(scs);        /* definitions are needed in prog. */
  771.     Target i   = 0;
  772.  
  773.     fprintf(fp,"#include %s\n\nint argcheck=ARGCHECK;\n\n",GOFC_INCLUDE);
  774.     outputCDecls(fp,scs);
  775.     outputCDicts(fp);
  776.  
  777.     setGoal("Compiling to C",t);
  778.     for (; nonNull(scs); scs=tl(scs)) {
  779.     outputCSc(fp,hd(scs));
  780.     soFar(i++);
  781.     }
  782.     done();
  783. }
  784.  
  785. static int *dictUse   = 0;        /* records dictionaries required   */
  786. static int num_cdicts  = 0;        /* dictionaries required       */
  787. static int num_sdicts = 0;        /* all dictionaries known to system*/
  788.  
  789. static List local identifyDeps(mn)    /* list all dependents scs for mn  */
  790. Name mn; {
  791.     List needed     = singleton(mn);    /* Start with dependents of mn       */
  792.     List scs        = NIL;
  793.     List ns        = NIL;
  794.     Int  i;
  795.  
  796.     num_sdicts = newDict(0);
  797.     dictUse    = (int *)calloc(num_sdicts,sizeof(int));
  798.     if (!dictUse) {
  799.     ERROR(0) "Cannot allocate dictionary use table"
  800.     EEND;
  801.     }
  802.     for (i=0; i<num_sdicts; i++)
  803.     dictUse[i] = (-1);        /* (-1) => not required           */
  804.  
  805.     while (nonNull(needed)) {        /* Cycle through to find all       */
  806.     Cell t = needed;        /* dependents ...           */
  807.     Cell n = hd(t);
  808.     needed = tl(needed);
  809.     if (isName(n)) {        /* Dependent is a name           */
  810.          if (!name(n).primDef && name(n).defn!=NEEDED) {
  811.           tl(t)        = scs;
  812.           scs         = t;
  813.          map1Proc(checkPrimDep,n,name(n).defn);
  814.         needed       = appendOnto(name(n).defn,needed);
  815.         name(n).defn = NEEDED;
  816.         }
  817.     }
  818.     else {                /* Dependent is a dictionary       */
  819.         if (dictUse[dictOf(n)]<0)
  820.         for (i=dictOf(n); (dictUse[i++]=0), i<num_sdicts; )
  821.             if (isAp(dict(i))) {    /* member function       */
  822.             if (isName(fun(dict(i))) &&
  823.                 whatIs(arg(dict(i)))==DICTCELL)
  824.                 needed = cons(fun(dict(i)),needed);
  825.             else
  826.                 if (fun(dict(i))!=nameUndefMem)
  827.                 internal("bad dict ap");
  828.             }
  829.             else            /* DICTCELL           */
  830.             if (dictOf(dict(i))==i)    /* past end of dictionary  */
  831.                 break;
  832.             else
  833.                 needed = cons(dict(i),needed);
  834.         }
  835.     }
  836.  
  837.     ns = scs;                /* number supercombinators       */
  838.     for (i=0; nonNull(ns); ns=tl(ns))
  839.     name(hd(ns)).number = i++;
  840.  
  841.     num_cdicts = 0;            /* number dictionaries           */
  842.     for (i=0; i<num_sdicts; i++)
  843.     if (dictUse[i]!=(-1))
  844.         dictUse[i] = num_cdicts++;
  845.  
  846.     return scs;
  847. }
  848.  
  849. static Void local checkPrimDep(n,m)    /* Check that primitive dependent  */
  850. Name n;                    /* m of n is supported by gofc       */
  851. Cell m; {
  852.     if (isName(m) && name(m).primDef == PRIM_NOGOFC) {
  853.     ERROR(0)
  854.      "Primitive function %s is not supported by the gofc runtime system\n",
  855.          primitives[name(m).number].ref
  856.     ETHEN
  857.     ERRTEXT "(used in the definition of %s)", textToStr(name(n).text)
  858.     EEND;
  859.     }
  860. }
  861.  
  862. static Void local outputCDecls(fp,scs)    /* print forward declarations for  */
  863. FILE *fp;                /* supercombinators required       */
  864. List scs; {
  865.     int num_scs = length(scs);
  866.  
  867.     startTable("extern Super ", ";", ";\n");
  868. #define declareSc(n) tableItem(fp,scNameOf(n))
  869.     mapProc(declareSc,scs);
  870. #undef  declareSc
  871.     finishTable(fp);
  872.  
  873.     fprintf(fp,"\nint   num_scs = %d;\nCell  sc[%d];",num_scs,num_scs);
  874.     fprintf(fp,"\nSuper *scNames[] = {\n");
  875.     startTable("  ", ", ", "\n");
  876. #define inArraySc(n) tableItem(fp,scNameOf(n))
  877.     mapProc(inArraySc,scs);
  878. #undef  inArraySc
  879.     finishTable(fp);
  880.     fprintf(fp,"};\n\n");
  881. }
  882.  
  883. static Void local outputCDicts(fp)    /* print definitions for dictionary*/
  884. FILE *fp; {                /* storage               */
  885.     char buffer[100];
  886.  
  887.     fprintf(fp,"int  num_cdicts = %d;\n",num_cdicts);
  888.  
  889.     if (num_cdicts==0) {
  890.     fprintf(fp,"Cell dict[]     = {0}; /* dummy entries */\n");
  891.     fprintf(fp,"int  dictImps[] = {0};\n\n");
  892.     }
  893.     else {
  894.     Int dn;
  895.     fprintf(fp,"Cell dict[] = {\n");
  896.     startTable("  ", ",", "\n");
  897.         for (dn=0; dn<num_sdicts; dn++) {
  898.         if (dictUse[dn]>=0) {
  899.                 if (isAp(dict(dn))) {
  900.             if (fst(dict(dn))==nameUndefMem)
  901.             tableItem(fp,"0");
  902.             else {
  903.             sprintf(buffer,"mkDict(%d)",
  904.                     dictUse[dictOf(arg(dict(dn)))]);
  905.             tableItem(fp,buffer);
  906.             }
  907.         }
  908.         else {
  909.             sprintf(buffer,"mkDict(%d)",dictUse[dictOf(dict(dn))]);
  910.             tableItem(fp,buffer);
  911.         }
  912.         }
  913.     }
  914.     finishTable(fp);
  915.     fprintf(fp,"};\nint dictImps[] = {\n");
  916.     startTable("  ", ",", "\n");
  917.     for (dn=0; dn<num_sdicts; dn++)
  918.         if (dictUse[dn]>=0)
  919.         if (isAp(dict(dn))) {
  920.             sprintf(buffer,"%d",name(fun(dict(dn))).number);
  921.             tableItem(fp,buffer);
  922.         }
  923.         else
  924.             tableItem(fp,"-1");
  925.     finishTable(fp);
  926.     fprintf(fp,"};\n\n");
  927.     }
  928. }
  929.  
  930. /* --------------------------------------------------------------------------
  931.  * Supercombinator C code generator:
  932.  *
  933.  * The C code generator re-interprets the sequence of machine instructions
  934.  * produced by the G-code code generator given above, using a simulated
  935.  * stack, in much the same way as described in Simon Peyton Jones's book,
  936.  * section 19.3.2.  To be quite honest, I don't think I really understood
  937.  * that section of the book until I started to work on this piece of code!
  938.  * ------------------------------------------------------------------------*/
  939.  
  940. static  int    rsp;            /* Runtime stack pointer       */
  941. static  int    rspMax;            /* Maximum value of stack pointer  */
  942. static  int    pushes;            /* number of actual pushes in code */
  943.  
  944. #define rPush  if (++rsp>=rspMax) rspMax=rsp
  945.  
  946. static Void local rspRecalc() {        /* Recalculate rsp after change to */
  947.     Int i = sp;                /* simulated stack pointer sp       */
  948.     for (rsp=(-1); i>=0; --i)
  949.     if (isNull(stack(i)) || stack(i)==mkOffset(i))
  950.         rsp++;
  951.     if (rsp>rspMax)            /* should never happen!           */
  952.     rspMax = rsp;
  953. }
  954.  
  955. /* --------------------------------------------------------------------------
  956.  * Output code for a single supercombinator:
  957.  * ------------------------------------------------------------------------*/
  958.  
  959. #define ppushed(n)  (isNull(pushed(n)) ? POP : pushed(n))
  960. #define tpushed(n)  (isNull(pushed(n)) ? TOP : pushed(n))
  961.  
  962. static Void local outputCSc(fp,n)    /* Print C code for supercombinator*/
  963. FILE *fp;
  964. Name n; {
  965.     List   instrs = heapUse(cCode(name(n).arity,name(n).code));
  966.     String s      = 0;
  967.  
  968.     if (name(n).arity<10)        /* Print header               */
  969.     fprintf(fp,"comb%d(%s)",name(n).arity,scNameOf(n));
  970.     else
  971.     fprintf(fp,"comb(%s,%d)",scNameOf(n),name(n).arity);
  972.  
  973.     fprintf(fp,"  /* ");        /* include supercombinator name       */
  974.     for (s=textToStr(name(n).text); *s; s++) {
  975.     fputc(*s,fp);
  976.     if (*s=='*' && *(s+1)=='/')    /* avoid premature comment ending  */
  977.         fputc(' ',fp);
  978.     }
  979.     fprintf(fp," */\n");
  980.  
  981.     if (pushes>0 && rspMax>name(n).arity)
  982.     fprintf(fp,"  needStack(%d);\n",rspMax-name(n).arity);
  983.  
  984.     for (; nonNull(instrs); instrs=tl(instrs)) {
  985.     Cell instr = hd(instrs);
  986.  
  987.     if (whatIs(instr)==C_LABEL) {    /* Handle printing of labels       */
  988.         instrs = tl(instrs);    /* move on to next instruction       */
  989.         if (isNull(instrs))
  990.         internal("no instr for label");
  991.         outputLabel(fp,intOf(snd(instr)));
  992.         fputc(':',fp);
  993.         instr   = hd(instrs);
  994.     }
  995.     else
  996.         fprintf(fp,"  ");
  997.  
  998.         outputCinst(fp,instr);
  999.     fprintf(fp,";\n");
  1000.     }
  1001.  
  1002.     fprintf(fp,"End\n\n");
  1003. }
  1004.  
  1005. static List local cCode(arity,pc)    /* simulate execution of G-code to */
  1006. Int  arity;                /* calculate corresponding C code  */
  1007. Addr pc; {
  1008.     Cell instrs = NIL;            /* holds sequence of C instrs       */
  1009.     Int  i;
  1010.     Cell t;
  1011.  
  1012.     clearStack();            /* initialise simulated stack       */
  1013.     for (i=0; i<=arity; i++) {
  1014.     push(mkOffset(i));
  1015.     }
  1016.     rsp    = arity;            /* and set Real stack ptr to match */
  1017.     rspMax = rsp;
  1018.     pushes = 0;
  1019.  
  1020. #define outC0(c)    instrs = cons(c,instrs)
  1021. #define outC1(c,o)    instrs = cons(ap(c,o),instrs)
  1022. #define outC2(c,o,p)    instrs = cons(ap(c,pair(o,p)),instrs)
  1023. #define outC3(c,o,p,q)    instrs = cons(ap(c,triple(o,p,q)),instrs)
  1024.  
  1025.     for (;;)
  1026.     switch (instrAt(pc)) {
  1027.  
  1028.         case iEND     : return rev(instrs);         /* end of code       */
  1029.  
  1030.         case iLABEL     : outC1(C_LABEL,         /* program label  */
  1031.                  mkInt(labAt(pc+1)));
  1032.                pc+=2;
  1033.                continue;
  1034.  
  1035.         case iLOAD     : push(mkOffset(intAt(pc+1)));     /* load from stack*/
  1036.                pc+=2;
  1037.                continue;
  1038.  
  1039.         case iCELL     : push(cellAt(pc+1));         /* load const Cell*/
  1040.                pc+=2;
  1041.                continue;
  1042.  
  1043.         case iCHAR     : push(mkChar(intAt(pc+1)));     /* load char const*/
  1044.                pc+=2;
  1045.                continue;
  1046.  
  1047.         /* the treatment of integers used here relies on the assumption*/
  1048.         /* that any number represented by a small int in the compiler  */
  1049.         /* can also be represented by a small int in the runtime system*/
  1050.  
  1051.         case iINT     : t = mkInt(intAt(pc+1));     /* load int const */
  1052.                if (!isSmall(t)) {         /* assume BIG int */
  1053.                    push(NIL);
  1054.                    rPush;
  1055.                    pushes++;
  1056.                    outC0(t);
  1057.                }
  1058.                else {                 /* assume SMALL   */
  1059.                    push(t);
  1060.                }
  1061.                pc+=2;
  1062.                continue;
  1063.  
  1064.         case iFLOAT  : push(NIL);             /* load float cnst*/
  1065.                rPush;
  1066.                pushes++;
  1067. #if BREAK_FLOATS
  1068.                outC0(mkFloat(floatFromParts
  1069.                         (cellAt(pc+1),cellAt(pc+2))));
  1070.                pc+=3;
  1071. #else
  1072.                outC0(mkFloat(floatAt(pc+1)));
  1073.                pc+=2;
  1074. #endif
  1075.                continue;
  1076.  
  1077.         case iFLUSH  : if (nonNull(top())) {     /* force top of   */
  1078.                    outC1(C_FLUSH,top());     /* simulated stack*/
  1079.                    top() = NIL;         /* onto real stack*/
  1080.                    rPush;
  1081.                    pushes++;
  1082.                }
  1083.                pc++;
  1084.                continue;
  1085.  
  1086.         case iSTRING : push(NIL);             /* load str const */
  1087.                rPush;
  1088.                pushes++;
  1089.                outC0(mkStr(textAt(pc+1)));
  1090.                pc+=2;
  1091.                continue;
  1092.  
  1093.         case iMKAP   : for (i=intAt(pc+1); i>0; --i){/* make AP nodes  */
  1094.                    if (isNull(pushed(0)))
  1095.                    if (isNull(pushed(1))) {
  1096.                        outC0(C_MKAP);
  1097.                        rsp--;
  1098.                    }
  1099.                    else
  1100.                        outC1(C_TOPARG,pushed(1));
  1101.                    else
  1102.                    if (isNull(pushed(1)))
  1103.                        outC1(C_TOPFUN,pushed(0));
  1104.                    else {
  1105.                        rPush;
  1106.                        pushes++;
  1107.                        outC2(C_PUSHPAIR,pushed(0),pushed(1));
  1108.                    }
  1109.                    drop();
  1110.                    top() = NIL;
  1111.                }
  1112.                pc+=2;
  1113.                continue;
  1114.  
  1115.         case iUPDATE : t = stack(intAt(pc+1));     /* update cell ...*/
  1116.                if (!isOffset(t))
  1117.                    internal("iUPDATE");
  1118.                    
  1119.                if(offsetOf(t)!=0)
  1120.                  stack(intAt(pc+1)) = NIL;
  1121.                if (isNull(pushed(0)))     /* update cell ...*/
  1122.                    rsp--;
  1123.  
  1124.                outC2(C_UPDATE,t,ppushed(0));
  1125.  
  1126.                drop();
  1127.                pc+=2;
  1128.                continue;
  1129.  
  1130.         case iUPDAP  : t = stack(intAt(pc+1));     /* update AP node */
  1131.                if (!isOffset(t))
  1132.                    internal("iUPDAP");
  1133.                if(offsetOf(t)!=0)
  1134.                  stack(intAt(pc+1)) = NIL;
  1135.  
  1136.                if (isNull(pushed(0)))
  1137.                    if (isNull(pushed(1))) {
  1138.                    outC1(C_UPDAP2,t);
  1139.                    rsp-=2;
  1140.                    }
  1141.                    else {
  1142.                    outC3(C_UPDAP,t,POP,pushed(1));
  1143.                    rsp--;
  1144.                    }
  1145.                else
  1146.                    if (isNull(pushed(1))) {
  1147.                    outC3(C_UPDAP,t,pushed(0),POP);
  1148.                                    rsp--;
  1149.                    }
  1150.                    else
  1151.                    outC3(C_UPDAP,t,pushed(0),pushed(1));
  1152.  
  1153.                drop();
  1154.                drop();
  1155.                pc+=2;
  1156.                continue;
  1157.  
  1158.         case iALLOC  : for (i=intAt(pc+1); i>0; --i){/* alloc loc vars */
  1159.                    rPush;
  1160.                    pushes++;
  1161.                    outC0(C_ALLOC);
  1162.                    push(mkOffset(rsp));
  1163.                }
  1164.                pc+=2;
  1165.                continue;
  1166.  
  1167.         case iSLIDE  : i = intAt(pc+1);         /* remove loc vars*/
  1168.                if (nonNull(top()))
  1169.                    i--;
  1170.                outC2(C_SLIDE,mkInt(i),tpushed(0));
  1171.                rsp -= i;
  1172.                sp  -= intAt(pc+1);
  1173.                            pc  += 2;
  1174.                continue;
  1175.  
  1176.         case iDICT     : if (isNull(top()))         /* dict lookup    */
  1177.                    internal("iDICT");
  1178.  
  1179.                if (whatIs(top())==DICTCELL)
  1180.                    top() = mkDict(dictOf(top())+intAt(pc+1));
  1181.                else
  1182.                    top() = ap(mkSelect(intAt(pc+1)),top());
  1183.  
  1184.                            pc+=2;                        /* dict lookup    */
  1185.                            continue;
  1186.  
  1187.         case iROOT     : t = mkOffset(0);         /* partial root   */
  1188.                for (i=intAt(pc+1); i>0; --i)
  1189.                    t = ap(ROOTFST,t);
  1190.                push(t);
  1191.                pc+=2;
  1192.                continue;
  1193.  
  1194.         case iRETURN : outC0(C_RETURN);         /* terminate       */
  1195.                pc++;
  1196.                continue;
  1197.  
  1198.         case iGOTO     : outC1(C_GOTO,         /* goto label       */
  1199.                  mkInt(labAt(pc+1)));
  1200.                pc+=2;
  1201.                continue;
  1202.  
  1203.         case iSETSTK : sp = intAt(pc+1);         /* set stack ptr  */
  1204.                rspRecalc();
  1205.                outC1(C_SETSTK,mkInt(rsp));
  1206.                pc += 2;
  1207.                continue;
  1208.  
  1209.         case iSTKIS  : sp = intAt(pc+1);         /* set stack ptr  */
  1210.                rspRecalc();             /* but no C code  */
  1211.                pc += 2;
  1212.                continue;
  1213.  
  1214.         case iINTEQ     :                  /* test integer ==*/
  1215.                outC2(C_INTEQ,mkInt(intAt(pc+1)),
  1216.                      mkInt(labAt(pc+2)));
  1217.                pc+=3;
  1218.                continue;
  1219.  
  1220.         case iINTGE     : push(NIL);             /* test integer >=*/
  1221.                rPush;
  1222.                pushes++;
  1223.                outC3(C_INTGE,mkInt(0),
  1224.                      mkInt(intAt(pc+1)),
  1225.                      mkInt(labAt(pc+2)));
  1226.                            pc+=3;
  1227.                continue;
  1228.  
  1229.         case iINTDV     : push(NIL);             /* test for mult  */
  1230.                rPush;
  1231.                pushes++;
  1232.                outC3(C_INTDV,mkInt(0),
  1233.                      mkInt(intAt(pc+1)),
  1234.                      mkInt(labAt(pc+2)));
  1235.                pc+=3;
  1236.                continue;
  1237.  
  1238.         case iTEST     : t = cellAt(pc+1);         /* test for cell  */
  1239.                switch (whatIs(t)) {
  1240.                    case UNIT     : i = 0;
  1241.                            break;
  1242.  
  1243.                    case TUPLE    : i = tupleOf(t);
  1244.                            break;
  1245.  
  1246.                    case NAME     : i = name(t).arity;
  1247.                            outC2(C_TEST,t,
  1248.                          mkInt(labAt(pc+2)));
  1249.                            break;
  1250.  
  1251.                    case CHARCELL : i = 0;
  1252.                            outC2(C_TEST,t,
  1253.                          mkInt(labAt(pc+2)));
  1254.                            break;
  1255.  
  1256.                    default         : internal("iTEST");
  1257.                }
  1258.  
  1259.                while (i-- > 0) {
  1260.                    rPush;
  1261.                    push(mkOffset(rsp));
  1262.                }
  1263.                pc+=3;
  1264.                continue;
  1265.  
  1266.         case iEVAL     : if (isNull(pushed(0)))     /* evaluate top() */
  1267.                    rsp--;
  1268.                outC1(C_EVAL,ppushed(0));
  1269.                drop();
  1270.                pc++;
  1271.                continue;
  1272.  
  1273.         default     : internal("illegal instruction");
  1274.                break;
  1275.     }
  1276.  
  1277. #undef outC0
  1278. #undef outC1
  1279. #undef outC2
  1280. #undef outC3
  1281. }
  1282.  
  1283. /* --------------------------------------------------------------------------
  1284.  * Insert heap use annotations:
  1285.  * ------------------------------------------------------------------------*/
  1286.  
  1287. static Int heapNeeded;            /* used to return # heap cells reqd*/
  1288.  
  1289. static List local heapUse(instrs)    /* add annotations for heap use       */
  1290. List instrs; {
  1291.     instrs = heapAnalyse(instrs);
  1292.     if (heapNeeded>0)
  1293.     instrs = cons(ap(C_HEAP,mkInt(heapNeeded)),instrs);
  1294.     return instrs;
  1295. }
  1296.  
  1297. static List local heapAnalyse(instrs)    /* analyse heap use in instruction */
  1298. List instrs; {
  1299.     Int  heap = 0;            /* number of heap cells needed     */
  1300.     List next;
  1301.  
  1302.     for (next=instrs; nonNull(next); next=tl(next))
  1303.     switch (whatIs(hd(next))) {
  1304.         case FLOATCELL  : heap+=4;        /*conservative overestimate*/
  1305.                   continue;        /*without BREAK_FLOATS this*/
  1306.                         /*will always use just one */
  1307.                         /*cell, with it may use 1-4*/
  1308.  
  1309.         case INTCELL    :            /*conservative overestimate*/
  1310.                         /*again. Small ints may not*/
  1311.                         /*require any heap storage */
  1312.         case STRCELL    :
  1313.         case C_MKAP        :
  1314.         case C_TOPFUN   :
  1315.         case C_TOPARG   :
  1316.         case C_PUSHPAIR :
  1317.         case C_ALLOC    : heap++;
  1318.         case C_UPDAP    :
  1319.         case C_UPDAP2   :
  1320.         case C_UPDATE   :
  1321.         case C_SLIDE    :
  1322.         case C_SETSTK   :
  1323.         case C_FLUSH    : continue;
  1324.  
  1325.         case C_INTGE    :
  1326.         case C_INTDV    : tl(next)          = heapAnalyse(tl(next));
  1327.                   fst3(snd(hd(next))) = mkInt(1+heapNeeded);
  1328.                   heapNeeded      = heap;
  1329.                   return instrs;
  1330.  
  1331.         case C_TEST        :
  1332.         case C_INTEQ    :
  1333.         case C_LABEL    :
  1334.         case C_GOTO     :
  1335.         case C_RETURN   :
  1336.         case C_EVAL        : tl(next)   = heapUse(tl(next));
  1337.                   heapNeeded = heap;
  1338.                               return instrs;
  1339.  
  1340.         default        : internal("heapAnalyse");
  1341.     }
  1342.  
  1343.     heapNeeded = heap;
  1344.     return instrs;
  1345. }
  1346.  
  1347. /* --------------------------------------------------------------------------
  1348.  * Output individual C code instructions:
  1349.  * ------------------------------------------------------------------------*/
  1350.  
  1351. static Void local outputCinst(fp,instr)    /* Output single C instruction       */
  1352. FILE *fp;
  1353. Cell instr; {
  1354.     switch (whatIs(instr)) {
  1355.     case INTCELL    : fprintf(fp,"pushInt(%d)",intOf(instr));
  1356.               break;
  1357.  
  1358.     case FLOATCELL  : fprintf(fp,"pushFloat(%s)",
  1359.                     floatToString(floatOf(instr)));
  1360.               break;
  1361.  
  1362.     case STRCELL    : fprintf(fp,"pushStr(");
  1363.               outputCStr(fp,textToStr(textOf(instr)));
  1364.               fputc(')',fp);
  1365.               break;
  1366.  
  1367.     case C_MKAP    : fprintf(fp,"mkap()");
  1368.               break;
  1369.  
  1370.     case C_TOPARG   : fprintf(fp,"toparg(");
  1371.               expr(fp,snd(instr));
  1372.               fputc(')',fp);
  1373.               break;
  1374.  
  1375.     case C_TOPFUN   : fprintf(fp,"topfun(");
  1376.               expr(fp,snd(instr));
  1377.               fputc(')',fp);
  1378.               break;
  1379.  
  1380.     case C_PUSHPAIR : fprintf(fp,"pushpair(");
  1381.               expr(fp,fst(snd(instr)));
  1382.               fputc(',',fp);
  1383.               expr(fp,snd(snd(instr)));
  1384.               fputc(')',fp);
  1385.               break;
  1386.  
  1387.     case C_UPDATE   : fprintf(fp,"update(%d,",offsetOf(fst(snd(instr))));
  1388.               expr(fp,snd(snd(instr)));
  1389.               fputc(')',fp);
  1390.               break;
  1391.  
  1392.     case C_UPDAP    : fprintf(fp,"updap(%d,",offsetOf(fst3(snd(instr))));
  1393.               expr(fp,snd3(snd(instr)));
  1394.               fputc(',',fp);
  1395.               expr(fp,thd3(snd(instr)));
  1396.               fputc(')',fp);
  1397.               break;
  1398.  
  1399.     case C_UPDAP2    : fprintf(fp,"updap2(%d)",offsetOf(snd(instr)));
  1400.               break;
  1401.  
  1402.     case C_ALLOC    : fprintf(fp,"alloc()");
  1403.               break;
  1404.  
  1405.     case C_SLIDE    : fprintf(fp,"slide(%d,",intOf(fst(snd(instr))));
  1406.               expr(fp,snd(snd(instr)));
  1407.               fputc(')',fp);
  1408.               break;
  1409.  
  1410.     case C_RETURN   : fprintf(fp,"ret()");
  1411.               break;
  1412.  
  1413.     case C_GOTO    : outputJump(fp,intOf(snd(instr)));
  1414.               break;
  1415.  
  1416.     case C_FLUSH    : fprintf(fp,"onto(");
  1417.               expr(fp,snd(instr));
  1418.               fputc(')',fp);
  1419.               break;
  1420.  
  1421.     case C_SETSTK   : fprintf(fp,"setstk(%d)",intOf(snd(instr)));
  1422.               break;
  1423.  
  1424.     case C_HEAP    : fprintf(fp,"heap(%d)",intOf(snd(instr)));
  1425.               break;
  1426.  
  1427.     case C_INTEQ    : fprintf(fp,"inteq(%d) ",intOf(fst(snd(instr))));
  1428.               outputJump(fp,intOf(snd(snd(instr))));
  1429.               break;
  1430.  
  1431.     case C_INTGE    : fprintf(fp,"intge(%d,%d) ",intOf(fst3(snd(instr))),
  1432.                              intOf(snd3(snd(instr))));
  1433.               outputJump(fp,intOf(thd3(snd(instr))));
  1434.               break;
  1435.  
  1436.     case C_INTDV    : fprintf(fp,"intdv(%d,%d) ",intOf(fst3(snd(instr))),
  1437.                              intOf(snd3(snd(instr))));
  1438.               outputJump(fp,intOf(thd3(snd(instr))));
  1439.               break;
  1440.  
  1441.     case C_TEST    : fprintf(fp,"test(");
  1442.               expr(fp,fst(snd(instr)));
  1443.               fprintf(fp,") ");
  1444.               outputJump(fp,intOf(snd(snd(instr))));
  1445.               break;
  1446.  
  1447.     case C_EVAL    : fprintf(fp,"eval(");
  1448.               expr(fp,snd(instr));
  1449.               fputc(')',fp);
  1450.               break;
  1451.  
  1452.     default        : internal("bad C code");
  1453.     }
  1454. }
  1455.  
  1456. /* --------------------------------------------------------------------------
  1457.  * Output small parts of an expression:
  1458.  * ------------------------------------------------------------------------*/
  1459.  
  1460. static Void local expr(fp,n)        /* print C expression for value       */
  1461. FILE *fp;
  1462. Cell n; {
  1463.  
  1464.     switch (whatIs(n)) {
  1465.  
  1466.     case TOP      : fprintf(fp,"top()");
  1467.             break;
  1468.  
  1469.     case POP      : fprintf(fp,"pop()");
  1470.             break;
  1471.  
  1472.     case OFFSET   : fprintf(fp,"offset(%d)",offsetOf(n));
  1473.             break;
  1474.  
  1475.     case CHARCELL : fprintf(fp,"mkChar(%d)",charOf(n));
  1476.             break;
  1477.  
  1478.     case INTCELL  : fprintf(fp,"mkSmall(%d)",intOf(n));
  1479.             break;
  1480.  
  1481.     case AP          : if (fst(n)==ROOTFST) {
  1482.                 fprintf(fp,"rootFst(");
  1483.                 expr(fp,arg(n));
  1484.                 fputc(')',fp);
  1485.             }
  1486.             else if (isSelect(fst(n))) {
  1487.                 fprintf(fp,"dsel(%d,",selectOf(fst(n)));
  1488.                 expr(fp,arg(n));
  1489.                 fputc(')',fp);
  1490.             }
  1491.             else
  1492.                 internal("exprAP");
  1493.             break;
  1494.  
  1495.     case DICTCELL : fprintf(fp,"dict[%d]",dictUse[dictOf(n)]);
  1496.             break;
  1497.  
  1498.     case UNIT     : fprintf(fp,"mkCfun(0)");
  1499.             break;
  1500.  
  1501.     case TUPLE    : fprintf(fp,"mkCfun(%d)",tupleOf(n));
  1502.             break;
  1503.  
  1504.     case NAME     : if (name(n).defn==CFUN)
  1505.                 fprintf(fp,"mkCfun(%d)",name(n).number);
  1506.             else if (name(n).primDef)
  1507.                 fprintf(fp,"%s",primitives[name(n).number].ref);
  1508.             else
  1509.                 fprintf(fp,"sc[%d]",name(n).number);
  1510.             break;
  1511.  
  1512.     default          : internal("expr");
  1513.     }
  1514. }
  1515.  
  1516. static Void local outputLabel(fp,lab)    /* print C program label       */
  1517. FILE *fp;
  1518. Int  lab; {
  1519.     if (lab<=26)
  1520.     fputc('a'+lab-1, fp);
  1521.     else
  1522.     fprintf(fp,"a%d",lab-26);
  1523. }
  1524.  
  1525. static Void local outputJump(fp,lab)    /* print jump to label, taking       */
  1526. FILE *fp;                /* special account of FAIL label   */
  1527. Int  lab; {
  1528.     if (lab==FAIL)
  1529.     fprintf(fp,"fail()");
  1530.     else {
  1531.     fprintf(fp,"goto ");
  1532.     outputLabel(fp,lab);
  1533.     }
  1534. }
  1535.  
  1536. static Void local outputCStr(fp,s)    /* print out string, taking care   */
  1537. FILE   *fp;                /* to avoid problems with C escape */
  1538. String s; {                /* sequences               */
  1539.     fputc('"',fp);
  1540.     for (; *s; s++) {
  1541.         if (*s=='\\' || *s=='"')
  1542.         fprintf(fp,"\\%c",*s);
  1543.     else if (isprint(*s))
  1544.         fputc(*s,fp);
  1545.     else if (*s=='\n')
  1546.         fprintf(fp,"\\n");
  1547.     else
  1548.         fprintf(fp,"\\%03o",(*s<0 ? *s+NUM_CHARS : *s));
  1549.     }
  1550.     fputc('"',fp);
  1551. }
  1552.  
  1553. static Bool local validCstring(s)    /* check whether string s is valid */
  1554. String s; {                /* C identifier               */
  1555.     for (; *s && isascii(*s) && isalnum(*s); s++)
  1556.     ;
  1557.     return *s=='\0';
  1558. }
  1559.  
  1560. static String local scNameOf(n)        /* get name of C implementation of */
  1561. Name n; {                /* a particular supercombinator       */
  1562.     String s = textToStr(name(n).text);
  1563.     static char buffer[100];
  1564.  
  1565.     if (validCstring(s) && strlen(s)<96)
  1566.     sprintf(buffer,"sc_%s",s);
  1567.     else
  1568.     sprintf(buffer,"sc_%d",name(n).number);
  1569.  
  1570.     return buffer;
  1571. }
  1572.  
  1573. /* --------------------------------------------------------------------------
  1574.  * Pretty printing of tables:
  1575.  * ------------------------------------------------------------------------*/
  1576.  
  1577. #define TABLEWIDTH 72
  1578. static int    tableCol;
  1579. static int    tableItems;
  1580. static String tableStart;
  1581. static String tableEndLine;
  1582. static String tableEndTab;
  1583.  
  1584. static Void local startTable(start,endLine,endTab)
  1585. String start;
  1586. String endLine;
  1587. String endTab; {
  1588.     tableStart   = start;
  1589.     tableEndLine = endLine;
  1590.     tableEndTab  = endTab;
  1591.     tableCol     = 0;
  1592.     tableItems   = 0;
  1593. }
  1594.  
  1595. static Void local finishTable(fp)
  1596. FILE *fp; {
  1597.     if (tableCol>0)
  1598.     fprintf(fp,tableEndTab);
  1599. }
  1600.  
  1601. static Void local tableItem(fp,s)
  1602. FILE   *fp;
  1603. String s; {
  1604.     int n = strlen(s);
  1605.  
  1606.     if (tableItems++ == 0) {
  1607.     fprintf(fp,tableStart);
  1608.     tableCol = strlen(tableStart);
  1609.     }
  1610.     else {
  1611.     if (tableCol+n+2>TABLEWIDTH) {
  1612.         fprintf(fp,"%s\n%s",tableEndLine,tableStart);
  1613.         tableCol = strlen(tableStart);
  1614.     }
  1615.     else {
  1616.         fprintf(fp,", ");
  1617.         tableCol+=2;
  1618.     }
  1619.     }
  1620.     fprintf(fp,"%s",s);
  1621.     tableCol += n;
  1622. }
  1623.  
  1624. /* --------------------------------------------------------------------------
  1625.  * Machine control:
  1626.  * ------------------------------------------------------------------------*/
  1627.  
  1628. Void machine(what)
  1629. Int what; {
  1630.     switch (what) {
  1631.     case RESET   : scDeps  = NIL;
  1632.                break;
  1633.  
  1634.     case MARK    : mark(scDeps);
  1635.                mark(shouldntFail);
  1636.                mark(functionReturn);
  1637.                mark(noAction);
  1638.                break;
  1639.  
  1640.     case INSTALL : machine(RESET);
  1641.                memory = (Memory)farCalloc(num_addrs,sizeof(MemCell));
  1642.                if (memory==0)
  1643.                fatal("Cannot allocate program memory");
  1644.  
  1645.                shouldntFail   = pair(mkInt(0),ERRCONT);
  1646.                functionReturn = pair(mkInt(0),UPDRETC);
  1647.                noAction          = pair(mkInt(0),RUNONC);
  1648.                break;
  1649.     }
  1650. }
  1651.  
  1652. /* ------------------------------------------------------------------------*/
  1653.